perm filename T2.F4[P11,LCS] blob
sn#439871 filedate 1979-07-19 generic text, type T, neo UTF8
C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C INTO THE IX ARRAY. IX ARRAY ADVANCES 2 WORDS AT A TIME.
C IF 2ND WRD OF EACH PAIR IS NON-ZERO THEN 1ST IS FLT. PT. NUM.
C KCNT IS WORD COUNT OF INPUT STRING.
SUBROUTINE MPACK(KCNT, I,IX,IPTR)
INTEGER FQDR
COMMON/IGEN/IGEN /FQDR/FQDR(28,27),INSN
CIN COMMON /TR/Q(80),QX(100),IIX(100),LX(12),INST(27,4),K
COMMON /TR/LX(12),K
DIMENSION I(1),WDS(18)
COMMON /WDZ/WDZ(14),JWD(12)
DATA WDS/'OUT','OSC','AD2','RAN','ENV','STR','AD3','AD4',
1 'MLT','DIV','RAH','END','REV','OPT','NOS','SUB','INP','COS'/,
1 WDZ/'PLAY','FINI','SRAT','NCHN','PRIN','CHA','POWE','SRT',
1 'WORD','GEN','SEG','SIN','INS','UNIT'/,
1 JWD/'C','D','E','F','G','A','B','P','*','/',0,0/
DATA IPP/'P'/,IFF/'F'/,IBB/'B'/,ISS/'S'/,
1 IDD/'D'/,I2/'2'/,I3/'3'/,I4/'4'/,I0/'0'/,I9/'9'/,IPP/'P'/
IX=I(1)
101 N=I(2)
L=I(3)
CALL PACKER(RNAM,I)
C NOW RNAM HAS PACKED WORD
IF(IGEN.NE.2)GO TO 1000
C IGEN=2=READING INSTRUMENT DEFINITION
CODE NUMS ARE 1-13 FOR UNIT GENS., 100+ FOR B, 200+ FOR P, 300+ FOR F.
C ORD. OF UNIT GENS:OUT,OSC,AD2,RAN,ENV,STR,AD3,AD4,MLT,DIV,RAH,END,REV
C OPT,NOS,SUB,INP,COS
C OPT=OPTIONAL, NOS=OSC WHICH ACCEPTS NEG. FREQ., COS=CONTINUING NOS.
IF(IX.EQ.IPP)GO TO 14
IF(IX.EQ.IFF)GO TO 15
IF(IX.EQ.IBB)GO TO 16
IF(IX.EQ.IDD)GO TO 142
C FPN = FREQ. PARAM. NUM. DPN = DUR. PARAM. NUM.
DO 102 IX=1,18
102 IF(RNAM.EQ.WDS(IX))RETURN
C SENDS BACK NUM FOR 1 TO 17
C IF NOT A KNOWN WORD THEN ERROR
999 IF(IGEN.EQ.2)GO TO 28
C SO INST NAME CAN START WITH 'P' (BUT NO 'P12X', ETC.)
CALL ERR(5)
141 JCVT=-1
GO TO 143
142 JCVT=1
143 N=L
L=I(4)
C SHIFT POINTER 1 TO RIGHT
KCNT=KCNT-1
GO TO 144
14 JCVT=0
144 J=200
C PN
18 IF(N.LT.I0.OR.N.GT.I9)GO TO 999
K2=0
K1=NASCI(N)
C CONVERTS ASCII CHAR. TO INTEGER
IF(KCNT.EQ.2)GO TO 19
C ARE THERE 2 DIGITS AFTER P, F OR B?
IF(L.LT.I0.OR.L.GT.I9)GO TO 999
K1=K1*10
K2=NASCI(L)
19 IX=J+K1+K2
IF(JCVT.EQ.0)RETURN
C NOW SET UP A FREQ OR DUR FLAG
FQDR(K1+K2-2,INSN)=JCVT
JCVT=0
RETURN
15 IF(N.EQ.IPP)GO TO 141
C JUMP FOR 'FP' = FREQ PARAM
J=300
C FN
GO TO 18
16 J=100
C BN
GO TO 18
C NEXT FOR OTHER (MUS10 TYPE) KEY WORDS.
1000 IF(KCNT.LT.3)GO TO 2000
C JUMP TO FIND NOTE NAMES, PARAMS, FUNCTS.
DO 1 K=1,15
IF(RNAM.NE.WDZ(K))GO TO 1
C THIS LIST BEGINS WITH CODE NUM. 400:
C PLAY,FINI,SRATE,NCHNS,PRINT,CHA,POWER,SRT,END,GEN,DUR,FREQ,INS,UNIT GEN
IX=K+399
RETURN
1 CONTINUE
IF(IX.EQ.IPP)GO TO 14
C CHECK FOR A PARAM NUM OR INST. NAME
28 IX=-IPTR
C SEND BACK NEG. POINTER TO I ARRAY SO IT WILL LOOK FOR INST. NAME.
RETURN
2000 DO 2 K=1,12
C FINDS (P1, P21, ETC.)
2 IF(IX.EQ.JWD(K))GO TO(5,11,7,4,6,8,9,14,15,16)K
GO TO 28
C A FUNC??
4 IF(N.GE.I0.AND.N.LE.I9)GO TO 15
IF(KCNT.EQ.3)GO TO 28
IX=510
GO TO 36
5 IX=501
C 'C'
C AT THIS POINT NOTE NUMBERS RUN FROM 500 TO 520 (CF TO BS)
GO TO 36
6 IX=513
C THE NOTE 'G'
36 IF(KCNT.EQ.1)RETURN
IF(N.EQ.IFF)GO TO 39
IF(N.NE.ISS) GO TO 28
C NOW IT'S NOT A NOTE
40 IX=IX+1
C SHARP
RETURN
39 IX=IX-1
C FLAT
RETURN
11 IX=504
C 'D'
GO TO 36
7 IF(KCNT.EQ.3)GO TO 4
C 'END' OR NOTE 'E'?
IX=507
GO TO 36
8 IX=516
GO TO 36
9 IX=519
GO TO 36
END
SUBROUTINE ERR(N)
COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
GO TO (1,2,3,4,5)N
1 WRITE(JTYPE,101)
STOP
101 FORMAT(' MISSING SEMICOLON')
2 WRITE(JTYPE,102)
STOP
102 FORMAT(' MISSING PARENTHESIS')
3 WRITE(JTYPE,103)
STOP
103 FORMAT(' MISSING COMMA')
4 WRITE(JTYPE,104)
104 FORMAT(' MISSING PLAY;')
5 WRITE(JTYPE,105)
105 FORMAT(' UNKNOWN WORD')
STOP
END
SUBROUTINE ARITH(Y,W,LL)
DIMENSION W(1)
COMMON /AR/IOP
7 X=W(LL-1)
GO TO (1,2,3,4,5),IOP
1 IF(Y.EQ.0)Y=16.
C 0 WILL ALWAYS TURN INTO 16 WITH MULT OR DIV.
X=X*Y
GO TO 6
2 IF(Y.EQ.0)Y=16.
X=X/Y
GO TO 6
3 X=X-Y
GO TO 6
4 X=X+Y
GO TO 6
5 X=X**Y
6 W(LL-1)=X
END